home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue49 / ComCorn / EventSink.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-02  |  2.8 KB  |  103 lines
  1. unit EventSink;
  2.  
  3. interface
  4.  
  5. uses Windows, ActiveX, Office_TLB;
  6.  
  7. type
  8.   TClickProc = procedure (const Ctrl: CommandBarButton;
  9.       var CancelDefault: WordBool) of object;
  10.  
  11.   TEventSink = class(TObject, IUnknown, IDispatch)
  12.   private
  13.     FClickProc: TClickProc;
  14.     { IUnknown }
  15.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  16.     function _AddRef: Integer; stdcall;
  17.     function _Release: Integer; stdcall;
  18.     { IDispatch }
  19.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  20.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  21.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  22.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  23.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  24.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  25.   public
  26.     constructor Create(ClickProc: TClickProc);
  27.   end;
  28.  
  29. implementation
  30.  
  31. { TEventSink }
  32.  
  33. constructor TEventSink.Create(ClickProc: TClickProc);
  34. begin
  35.   @FClickProc := @ClickProc;
  36.   inherited Create;
  37. end;
  38.  
  39. { TEventSink.IUnknown }
  40.  
  41. function TEventSink._AddRef: Integer;
  42. begin
  43.   // No need to implement, since lifetime is tied to add-in
  44.   Result := 2;
  45. end;
  46.  
  47. function TEventSink._Release: Integer;
  48. begin
  49.   // No need to implement, since lifetime is tied to add-in
  50.   Result := 1;
  51. end;
  52.  
  53. function TEventSink.QueryInterface(const IID: TGUID; out Obj): HResult;
  54. begin
  55.   // First look for my own implementation of an interface
  56.   // (I implement IUnknown and IDispatch).
  57.   if GetInterface(IID, Obj) then
  58.     Result := S_OK
  59.   // Next, if they are looking for outgoing interface, recurse to return
  60.   // our IDispatch pointer.
  61.   else if IsEqualIID(IID, DIID__CommandBarButtonEvents) then
  62.     Result := QueryInterface(IDispatch, Obj)
  63.   // For everything else, return an error.
  64.   else
  65.     Result := E_NOINTERFACE;
  66. end;
  67.  
  68. { TEventSink.IDispatch }
  69.  
  70. function TEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  71.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  72. begin
  73.   Result := E_NOTIMPL;
  74. end;
  75.  
  76. function TEventSink.GetTypeInfo(Index, LocaleID: Integer;
  77.   out TypeInfo): HResult;
  78. begin
  79.   Pointer(TypeInfo) := nil;
  80.   Result := E_NOTIMPL;
  81. end;
  82.  
  83. function TEventSink.GetTypeInfoCount(out Count: Integer): HResult;
  84. begin
  85.   Count := 0;
  86.   Result := S_OK;
  87. end;
  88.  
  89. function TEventSink.Invoke(DispID: Integer; const IID: TGUID;
  90.   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  91.   ArgErr: Pointer): HResult;
  92. var
  93.   DispParams: PVariantArgList;
  94. begin
  95.   DispParams := TDispParams(Params).rgvarg;
  96.   // Pass click event back to add-in
  97.   if DispID = 1 then
  98.     FClickProc(CommandBarButton(DispParams^[0].dispVal), DispParams^[1].pBool^);
  99.   Result := S_OK;
  100. end;
  101.  
  102. end.
  103.